home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / clisp-c.zoo / defstruc.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1993-06-05  |  33.1 KB  |  737 lines

  1. ; Sources für DEFSTRUCT Macro.
  2. ; Bruno Haible 13.04.1988, 22.08.1988
  3. ; umgeschrieben am 02.09.1989 von Bruno Haible
  4.  
  5. (in-package "SYSTEM")
  6.  
  7. (defsetf %structure-ref %structure-store)
  8.  
  9. #| Erklärung der auftretenden Datentypen:
  10.  
  11.    (get name 'DEFSTRUCT-DESCRIPTION) =
  12.      #(names type keyword-constructor slotlist defaultfun0 defaultfun1 ...)
  13.  
  14.    names ist eine Codierung der INCLUDE-Verschachtelung für Structure name:
  15.    names = (name_1 ... name_i-1 . name_i) wobei name=name_1,
  16.      name_1 enthält name_2, ..., name_i-1 enthält name_i.
  17.  
  18.    type (wenn der Typ der ganzen Structure gemeint ist):
  19.       = T                      Abspeicherung als normale Structure
  20.       = LIST                   Abspeicherung als Liste
  21.       = VECTOR                 Abspeicherung als (simple-)Vector
  22.       = (VECTOR element-type)  Abspeicherung als Vector mit Element-Typ
  23.  
  24.    keyword-constructor = NIL oder der Name des Keyword-Constructor
  25.  
  26.    slotlist ist eine gepackte Beschreibung der einzelnen slots einer Structure:
  27.    slotlist = ({slot}*)
  28.    slot = (name offset default type readonly)
  29.    wobei name der Slotname ist,
  30.               (NIL für den Slot, in dem der Structure-Name steht)
  31.          default der Defaultwert ist:
  32.               entweder eine Konstante, die zum Defaultwert evaluiert,
  33.               oder eine Form (ein Symbol oder eine Liste (SVREF ...)), die
  34.               bei Auswertung in einem beliebigen Environment eine Funktion
  35.               liefert, die bei Aufruf den Defaultwert liefert.
  36.          type der deklarierte Type für diesen Slot ist,
  37.          readonly = NIL oder = T angibt, ob dieser Slot readonly ist, d.h.
  38.               nach dem Aufbau der Structure nicht mehr mit (setf ...)
  39.               verändert werden kann.
  40.    Bei type = T belegt der Structure-Name den Slot 0, wird aber nicht in der
  41.      slotlist aufgeführt, da zu seiner Initialisierung nichts zu tun ist.
  42.  
  43. |#
  44.  
  45.  
  46. #| (ds-symbol-or-error x) liefert eine Fehlermeldung, falls x kein Symbol ist.
  47. |#
  48. (defun ds-symbol-or-error (x)
  49.   (unless (symbolp x)
  50.     (error #+DEUTSCH "~S: Das ist kein Symbol: ~S"
  51.            #+ENGLISH "~S: this is not a symbol: ~S"
  52.            #+FRANCAIS "~S : Ceci n'est pas un symbole: ~S"
  53.            'defstruct x
  54. ) ) )
  55.  
  56. #| Hilfsfunktion für beide Konstruktoren:
  57.    (ds-arg-default arg slot)
  58.    liefert zu einem Argument arg (Teil einer Argumentliste) den Teil der
  59.    Argumentliste, der dieses Argument mit dem Default für slot bindet.
  60. |#
  61.  
  62. (defun ds-arg-default (arg slot)
  63.   (let ((default (third slot)))
  64.     ; Default ist entweder Konstante oder Funktion oder Symbol
  65.     (if (constantp default)
  66.       (if (null default) arg `(,arg ,default))
  67.       `(,arg (SYS::%FUNCALL ,default))
  68. ) ) )
  69.  
  70. #| Hilfsfunktion für beide Konstruktoren:
  71.    (ds-make-constructor-body type name names size slotlist)
  72.    liefert den Ausdruck, der eine Structure vom vorgegebenen Typ
  73.    kreiert und füllt.
  74. |#
  75. (defun ds-make-constructor-body (type name names size slotlist)
  76.   `(LET ((OBJECT
  77.            ,(cond ((eq type 'T) `(%MAKE-STRUCTURE ',names ,size))
  78.                   ((eq type 'LIST) `(MAKE-LIST ,size))
  79.                   ((consp type) `(MAKE-ARRAY ,size :ELEMENT-TYPE ',(second type)))
  80.                   (t `(MAKE-ARRAY ,size))
  81.             )
  82.         ))
  83.      ,@(mapcar
  84.          #'(lambda (slot &aux (offset (second slot)))
  85.              `(SETF
  86.                 ,(cond ((eq type 'T)
  87.                         `(%STRUCTURE-REF ',name OBJECT ,offset) )
  88.                        ((eq type 'LIST)
  89.                         `(NTH ,offset OBJECT) )
  90.                        ((eq type 'VECTOR)
  91.                         `(SVREF OBJECT ,offset) )
  92.                        (t `(AREF OBJECT ,offset) )
  93.                  )
  94.                 ,(if (first slot)
  95.                    `(THE ,(fourth slot) ,(first slot))
  96.                    `(QUOTE ,(third slot))
  97.               )  )
  98.            )
  99.          slotlist
  100.        )
  101.      OBJECT
  102. )  )
  103.  
  104. #| Hilfsfunktion für ds-make-boa-constructor:
  105.  
  106.    (ds-arg-with-default arg slotlist)
  107.    liefert zu einem Argument arg (Teil einer Argumentliste) den Teil der
  108.    Argumentliste, der dieses Argument mit dem richtigen Defaultwert bindet.
  109. |#
  110.  
  111. (defun ds-arg-with-default (arg slotlist)
  112.   (if (listp arg)
  113.     ; Defaultwert ist bereits mitgegeben
  114.     arg
  115.     ; nur ein Symbol
  116.     (let ((slot (find arg slotlist :key #'first :test #'eq)))
  117.       (if slot
  118.         ; Slot gefunden -> dessen Defaultwert nehmen
  119.         (ds-arg-default arg slot)
  120.         ; Slot nicht gefunden, kein Defaultwert
  121.         arg
  122. ) ) ) )
  123.  
  124. #| (ds-make-boa-constructor descriptor type name names size slotlist)
  125.    liefert die Form, die den BOA-Konstrukor definiert.
  126. |#
  127. (defun ds-make-boa-constructor (descriptor type name names size slotlist)
  128.   (let ((constructorname (first descriptor))
  129.         (arglist (second descriptor)))
  130.     ; auf &KEY und &ALLOW-OTHER-KEYS testen:
  131.     (let ((keying (or (member '&KEY arglist :test #'eq)
  132.                       (member '&ALLOW-OTHER-KEYS arglist :test #'eq)
  133.          ))       )
  134.       (when keying
  135.         (error #+DEUTSCH "~S ~S: Die Argumentliste für eine keywordfreie Konstruktorfunktion ~S darf kein ~S enthalten: ~S"
  136.                #+ENGLISH "~S ~S: the argument list for the BOA contructor ~S must not contain ~S: ~S"
  137.                #+FRANCAIS "~S ~S : La liste d'arguments pour un constructeur ~S libre de mot-clés ne peux pas contenir ~S: ~S"
  138.                'defstruct name constructorname (car keying) arglist
  139.     ) ) )
  140.     ; angegebene Argumente sammeln:
  141.     (let* ((argnames
  142.              (let ((L nil))
  143.                (dolist (arg arglist)
  144.                  (unless (member arg lambda-list-keywords :test #'eq)
  145.                    (push (if (listp arg) (first arg) arg) L)
  146.                ) )
  147.                (nreverse L)
  148.            ) )
  149.            ; argnames ist die Liste aller bereits in der Paramterliste mit
  150.            ; Werten versehenen Argumente.
  151.            (new-arglist ; neue Argumentliste
  152.              `(; required args:
  153.                ,@(do ((arglistr arglist (cdr arglistr))
  154.                       (arg)
  155.                       (required-args nil))
  156.                      ((or (endp arglistr)
  157.                           (member (setq arg (car arglistr)) lambda-list-keywords :test #'eq)
  158.                       )
  159.                       (nreverse required-args)
  160.                      )
  161.                    (push arg required-args)
  162.                  )
  163.                ; optional args:
  164.                ,@(do ((arglistr (cdr (member '&optional arglist :test #'eq)) (cdr arglistr))
  165.                       (arg)
  166.                       (optionals nil))
  167.                      ((or (endp arglistr)
  168.                           (member (setq arg (car arglistr)) lambda-list-keywords :test #'eq)
  169.                       )
  170.                       (if (null optionals) nil (cons '&optional (nreverse optionals)))
  171.                      )
  172.                    (push (ds-arg-with-default arg slotlist) optionals)
  173.                  )
  174.                ; rest arg:
  175.                ,@(let ((arglistr (member '&rest arglist :test #'eq)))
  176.                    (if arglistr `(&rest ,(second arglistr)) '())
  177.                  )
  178.                ; aux args:
  179.                &aux
  180.                ,@(do ((aux-args-r (cdr (member '&aux arglist :test #'eq)) (cdr aux-args-r))
  181.                       (aux-arg)
  182.                       (new-aux-args nil))
  183.                      ((or (null aux-args-r)
  184.                           (member (setq aux-arg (car aux-args-r)) lambda-list-keywords :test #'eq)
  185.                       )
  186.                       (nreverse new-aux-args)
  187.                      )
  188.                    (push (ds-arg-with-default aux-arg slotlist) new-aux-args)
  189.                  )
  190.                ,@(let ((slotinitlist nil))
  191.                    (dolist (slot slotlist)
  192.                      (when (first slot)
  193.                        (unless (member (first slot) argnames :test #'eq)
  194.                          (push (ds-arg-with-default (first slot) slotlist) slotinitlist)
  195.                    ) ) )
  196.                    (nreverse slotinitlist)
  197.               )  )
  198.           ))
  199.       `(DEFUN ,constructorname ,new-arglist
  200.          ,(ds-make-constructor-body type name names size slotlist)
  201.        )
  202. ) ) )
  203.  
  204. #| (ds-make-keyword-constructor descriptor type name names size slotlist)
  205.    liefert die Form, die den Keyword-Konstruktor definiert.
  206. |#
  207. (defun ds-make-keyword-constructor (descriptor type name names size slotlist)
  208.   `(DEFUN ,descriptor
  209.      (&KEY
  210.       ,@(mapcap
  211.           #'(lambda (slot)
  212.               (if (first slot) (list (ds-arg-default (first slot) slot)) '())
  213.             )
  214.           slotlist
  215.      )  )
  216.      ,(ds-make-constructor-body type name names size slotlist)
  217. )  )
  218.  
  219. #| (ds-make-pred predname type name name-offset)
  220.    liefert die Form, die das Typtestprädikat für die Structure name kreiert.
  221.    Dabei ist:
  222.    type         der Typ der Structure,
  223.    name         der Name der Structure,
  224.    predname     der Name des Typtestprädikats,
  225.    name-offset  (nur bei type /= T maßgeblich)
  226.                 die Stelle, an der der Name abgespeichert wird.
  227. |#
  228. (defun ds-make-pred (predname type name name-offset)
  229.   `(,@(if (eq type 'T) `((PROCLAIM '(INLINE ,predname))) '())
  230.     (DEFUN ,predname (OBJECT)
  231.       ,(if (eq type 'T)
  232.          `(%STRUCTURE-TYPE-P ',name OBJECT)
  233.          (if (eq type 'LIST)
  234.            `(AND (CONSP OBJECT)
  235.                  ,@(if (eql name-offset 0)
  236.                      `((EQ (CAR OBJECT) ',name))
  237.                      `((> (LENGTH OBJECT) ,name-offset)
  238.                        (EQ (NTH ,name-offset OBJECT) ',name)
  239.                       )
  240.             )      )
  241.            `(AND (SIMPLE-VECTOR-P OBJECT)
  242.                  (> (LENGTH OBJECT) ,name-offset)
  243.                  (EQ (SVREF OBJECT ,name-offset) ',name)
  244.             )
  245.        ) )
  246.    ))
  247. )
  248.  
  249. (defun ds-make-copier (copiername name type)
  250.   (declare (ignore name))
  251.   `(,@(if (or (eq type 'T) (eq type 'LIST))
  252.         `((PROCLAIM '(INLINE ,copiername)))
  253.         '()
  254.       )
  255.     (DEFUN ,copiername (STRUCTURE)
  256.       ,(if (eq type 'T)
  257.          '(%COPY-STRUCTURE STRUCTURE)
  258.          (if (eq type 'LIST)
  259.            '(COPY-LIST STRUCTURE)
  260.            (if (consp type)
  261.              `(LET* ((OBJ-LENGTH (ARRAY-TOTAL-SIZE STRUCTURE))
  262.                      (OBJECT (MAKE-ARRAY OBJ-LENGTH :ELEMENT-TYPE (QUOTE ,(second type))))
  263.                     )
  264.                 (DOTIMES (I OBJ-LENGTH OBJECT)
  265.                   (SETF (AREF OBJECT I) (AREF STRUCTURE I))
  266.               ) )
  267.              `(LET* ((OBJ-LENGTH (LENGTH STRUCTURE))
  268.                      (OBJECT (MAKE-ARRAY OBJ-LENGTH)))
  269.                 (DOTIMES (I OBJ-LENGTH OBJECT)
  270.                    (SETF (SVREF OBJECT I) (SVREF STRUCTURE I))
  271.               ) )
  272.        ) ) )
  273. )  ))
  274.  
  275. (defun ds-make-accessors (name type concname slotlist)
  276.   (mapcap
  277.     #'(lambda (slot)
  278.         (if (first slot)
  279.           (let ((accessorname (concat-pnames concname (first slot)))
  280.                 (offset (second slot))
  281.                 (slottype (fourth slot)))
  282.             `((PROCLAIM '(FUNCTION ,accessorname (,name) ,slottype))
  283.               (PROCLAIM '(INLINE ,accessorname))
  284.               (DEFUN ,accessorname (OBJECT)
  285.                 (THE ,slottype
  286.                   ,(if (eq type 'T)
  287.                      `(%STRUCTURE-REF ',name OBJECT ,offset)
  288.                      (if (eq type 'LIST)
  289.                        `(NTH ,offset OBJECT)
  290.                        (if (consp type)
  291.                          `(AREF OBJECT ,offset)
  292.                          `(SVREF OBJECT ,offset)
  293.              )) )  ) ) )
  294.           )
  295.           '()
  296.       ) )
  297.     slotlist
  298. ) )
  299.  
  300. (defun ds-make-defsetfs (name type concname slotlist)
  301.   (mapcap
  302.     #'(lambda (slot)
  303.         (if (and (first slot) (not (fifth slot))) ; not READ-ONLY
  304.           (let ((accessorname (concat-pnames concname (first slot)))
  305.                 (offset (second slot))
  306.                 (slottype (fourth slot)))
  307.             `((DEFSETF ,accessorname (STRUCT) (VALUE)
  308.                 ,(if (eq type 'T)
  309.                    `(LIST '%STRUCTURE-STORE '',name
  310.                       STRUCT
  311.                       ,offset
  312.                       ,(if (eq 'T slottype)
  313.                          `VALUE
  314.                          `(LIST 'THE ',slottype VALUE)
  315.                     )  )
  316.                    (if (eq type 'LIST)
  317.                      `(LIST 'SETF (LIST 'NTH ,offset STRUCT) VALUE)
  318.                      (if (consp type)
  319.                        `(LIST 'SETF (LIST 'AREF STRUCT ,offset) VALUE)
  320.                        `(LIST 'SETF (LIST 'SVREF STRUCT ,offset) VALUE)
  321.              ))  ) ) )
  322.       ) ) )
  323.     slotlist
  324. ) )
  325.  
  326. (defmacro defstruct (name-and-options . docstring-and-slotargs)
  327.   (let ((name                              name-and-options)
  328.         (options                           nil)
  329.         (conc-name-option                  t)
  330.         (constructor-option-list           nil)
  331.         (keyword-constructor               nil)
  332.         (copier-option                     t)
  333.         (predicate-option                  0)
  334.         (include-option                    nil)
  335.          names
  336.         (print-function-option             nil)
  337.         (type-option                       t)
  338.         (named-option                      0)
  339.         (initial-offset-option             0)
  340.         (initial-offset                    0)
  341.         (docstring                         nil)
  342.         (slotargs                          docstring-and-slotargs)
  343.          size
  344.         (include-skip                      0)
  345.         (slotlist                          nil)
  346.         (slotdefaultvars                   nil)
  347.         (slotdefaultfuns                   nil)
  348.          constructor-forms                      )
  349.     ;; name-and-options überprüfen:
  350.     (when (listp name-and-options)
  351.       (setq name (first name-and-options))
  352.       (setq options (rest name-and-options))
  353.     ) ; andernfalls sind name und options schon korrekt.
  354.     (unless (and (symbolp name) (not (keywordp name)))
  355.       (error #+DEUTSCH "~S: Falsche Syntax für Name und Optionen: ~S"
  356.              #+ENGLISH "~S: invalid syntax for name and options: ~S"
  357.              #+FRANCAIS "~S : Mauvaise syntaxe pour un nom et des options: ~S"
  358.              'defstruct name-and-options
  359.     ) )
  360.     ; name ist ein Symbol, options die Liste der Optionen.
  361.     ;; Abarbeitung der Optionen:
  362.     (dolist (option options)
  363.       (when (keywordp option) (setq option (list option))) ; Option ohne Argumente
  364.       (if (listp option)
  365.         (if (keywordp (car option))
  366.           (case (first option)
  367.             (:CONC-NAME
  368.                (setq conc-name-option (or (second option) ""))
  369.             )
  370.             (:CONSTRUCTOR
  371.                (if (atom (cdr option))
  372.                  ; Default-Keyword-Constructor
  373.                  (push (concat-pnames "MAKE-" name) constructor-option-list)
  374.                  (let ((arg (second option)))
  375.                    (ds-symbol-or-error arg)
  376.                    (push
  377.                      (if (atom (cddr option))
  378.                        arg ; Keyword-Constructor
  379.                        (if (not (listp (third option)))
  380.                          (error #+DEUTSCH "~S ~S: Argumentliste muß eine Liste sein: ~S"
  381.                                 #+ENGLISH "~S ~S: argument list should be a list: ~S"
  382.                                 #+FRANCAIS "~S ~S : La liste d'arguments doit être une liste: ~S"
  383.                                 'defstruct name (third option)
  384.                          )
  385.                          (rest option) ; BOA-Constructor
  386.                      ) )
  387.                      constructor-option-list
  388.             )  ) ) )
  389.             (:COPIER
  390.                (when (consp (cdr option))
  391.                  (let ((arg (second option)))
  392.                    (ds-symbol-or-error arg)
  393.                    (setq copier-option arg)
  394.             )  ) )
  395.             (:PREDICATE
  396.                (when (consp (cdr option))
  397.                  (let ((arg (second option)))
  398.                    (ds-symbol-or-error arg)
  399.                    (setq predicate-option arg)
  400.             )  ) )
  401.             (:INCLUDE
  402.                (if (null include-option)
  403.                  (setq include-option option)
  404.                  (error #+DEUTSCH "~S ~S: Es darf nur ein :INCLUDE-Argument geben: ~S"
  405.                         #+ENGLISH "~S ~S: At most one :INCLUDE argument may be specified: ~S"
  406.                         #+FRANCAIS "~S ~S : Il ne peut y avoir qu'un argument :INCLUDE: ~S"
  407.                         'defstruct name options
  408.             )  ) )
  409.             (:PRINT-FUNCTION
  410.                (let ((arg (second option)))
  411.                  (when (and (consp arg) (eq (first arg) 'FUNCTION))
  412.                    (warn #+DEUTSCH "~S: Bei :PRINT-FUNCTION ist FUNCTION bereits implizit.~@
  413.                                     Verwende daher ~S statt ~S."
  414.                          #+ENGLISH "~S: Use of :PRINT-FUNCTION implicitly applies FUNCTION.~@
  415.                                     Therefore using ~S instead of ~S."
  416.                          #+FRANCAIS "~S : FUNCTION est déjà implicite avec :PRINT-FUNCTION.~@
  417.                                      C'est pourquoi ~S est utilisé au lieu de ~S."
  418.                          'defstruct (second arg) arg
  419.                    )
  420.                    (setq arg (second arg))
  421.                  )
  422.                  (setq print-function-option
  423.                    (if (symbolp arg)
  424.                      ; ein Ausdruck, der eine eventuelle lokale Definition
  425.                      ; von arg mitberücksichtigt, aber nicht erfordert:
  426.                      `(FUNCTION ,(concat-pnames name "-PRINT-FUNCTION")
  427.                         (LAMBDA (STRUCT STREAM DEPTH)
  428.                           (,arg STRUCT STREAM DEPTH)
  429.                       ) )
  430.                      `#',arg
  431.             )  ) ) )
  432.             (:TYPE (setq type-option (second option)))
  433.             (:NAMED (setq named-option t))
  434.             (:INITIAL-OFFSET (setq initial-offset-option (or (second option) 0)))
  435.             (T (error #+DEUTSCH "~S ~S: Die Option ~S gibt es nicht."
  436.                       #+ENGLISH "~S ~S: unknown option ~S"
  437.                       #+FRANCAIS "~S ~S : Option ~S non reconnue."
  438.                       'defstruct name (first option)
  439.           ) )  )
  440.           (error #+DEUTSCH "~S ~S: Falsche Syntax in ~S-Option: ~S"
  441.                  #+ENGLISH "~S ~S: invalid syntax in ~S option: ~S"
  442.                  #+FRANCAIS "~S ~S : Mauvaise syntaxe dans l'option ~S: ~S"
  443.                  'defstruct name 'defstruct option
  444.         ) )
  445.         (error #+DEUTSCH "~S ~S: Das ist keine ~S-Option: ~S"
  446.                #+ENGLISH "~S ~S: not a ~S option: ~S"
  447.                #+FRANCAIS "~S ~S : Ceci n'est pas une option ~S: ~S"
  448.                'defstruct name 'defstruct option
  449.     ) ) )
  450.     ; conc-name-option ist entweder T oder "" oder das :CONC-NAME-Argument.
  451.     ; constructor-option-list ist eine Liste aller :CONSTRUCTOR-Argumente,
  452.     ;   jeweils in der Form  symbol  oder  (symbol arglist . ...).
  453.     ; copier-option ist entweder T oder das :COPIER-Argument.
  454.     ; predicate-option ist entweder 0 oder das :PREDICATE-Argument.
  455.     ; include-option ist entweder NIL oder die gesamte :INCLUDE-Option.
  456.     ; print-function-option ist NIL oder eine Form, die die Print-Function
  457.     ;   liefert.
  458.     ; type-option ist entweder T oder das :TYPE-Argument.
  459.     ; named-option ist entweder 0 oder T.
  460.     ; initial-offset-option ist entweder 0 oder das :INITIAL-OFFSET-Argument.
  461.     ;; Überprüfung der Optionen:
  462.     (setq named-option (or (eq type-option 'T) (eq named-option 'T)))
  463.     ; named-option (NIL oder T) gibt an, ob der Name in der Structure steckt.
  464.     (if named-option
  465.       (when (eql predicate-option 0)
  466.         (setq predicate-option (concat-pnames name "-P")) ; Defaultname
  467.       )
  468.       (unless (or (eql predicate-option 0) (eq predicate-option 'NIL))
  469.         (error #+DEUTSCH "~S ~S: Bei unbenannten Structures kann es kein :PREDICATE geben."
  470.                #+ENGLISH "~S ~S: There is no :PREDICATE on unnamed structures."
  471.                #+FRANCAIS "~S ~S : Il ne peut pas y avoir de :PREDICATE avec des structures anonymes."
  472.                'defstruct name
  473.     ) ) )
  474.     ; predicate-option ist
  475.     ;   bei named-option=T: entweder NIL oder der Name des Typtestprädikats,
  476.     ;   bei named-option=NIL bedeutungslos.
  477.     (if (eq conc-name-option 'T)
  478.       (setq conc-name-option (string-concat (string name) "-"))
  479.     )
  480.     ; conc-name-option ist der Namensprefix.
  481.     (if (null constructor-option-list)
  482.       (setq constructor-option-list (list (concat-pnames "MAKE-" name)))
  483.       (setq constructor-option-list (remove 'NIL constructor-option-list))
  484.     )
  485.     ; constructor-option-list ist eine Liste aller zu kreierenden Konstruktoren,
  486.     ;   jeweils in der Form  symbol  oder  (symbol arglist . ...).
  487.     (if (eq copier-option 'T)
  488.       (setq copier-option (concat-pnames "COPY-" name))
  489.     )
  490.     ; copier-option ist entweder NIL oder der Name der Kopierfunktion.
  491.     (unless (or (eq type-option 'T)
  492.                 (eq type-option 'VECTOR)
  493.                 (eq type-option 'LIST)
  494.                 (and (consp type-option) (eq (first type-option) 'VECTOR))
  495.             )
  496.       (error #+DEUTSCH "~S ~S: Unzulässige :TYPE-Option ~S"
  497.              #+ENGLISH "~S ~S: invalid :TYPE option ~S"
  498.              #+FRANCAIS "~S ~S : Option :TYPE inadmissible: ~S"
  499.              'defstruct name type-option
  500.     ) )
  501.     ; type-option ist entweder T oder LIST oder VECTOR oder (VECTOR ...)
  502.     (unless (and (integerp initial-offset-option) (>= initial-offset-option 0))
  503.       (error #+DEUTSCH "~S ~S: Der :INITIAL-OFFSET muß ein Integer >=0 sein, nicht ~S"
  504.              #+ENGLISH "~S ~S: The :INITIAL-OFFSET must be a nonnegative integer, not ~S"
  505.              #+FRANCAIS "~S ~S : :INITIAL-OFFSET doit être un entier positif ou zéro et non ~S"
  506.              'defstruct name initial-offset-option
  507.     ) )
  508.     ; initial-offset-option ist ein Integer >=0.
  509.     (when (and (plusp initial-offset-option) (eq type-option 'T))
  510.       (error #+DEUTSCH "~S ~S: :INITIAL-OFFSET darf nur zusammen mit :TYPE angegeben werden: ~S"
  511.              #+ENGLISH "~S ~S: :INITIAL-OFFSET must not be specified without :TYPE : ~S"
  512.              #+FRANCAIS "~S ~S : :INITIAL-OFFSET ne peut être précisé qu'ensemble avec :TYPE: ~S"
  513.              'defstruct name options
  514.     ) )
  515.     ; Bei type-option=T ist initial-offset-option=0.
  516.     (when (eq type-option 'T) (setq include-skip 1))
  517.     ; include-skip ist 1 bei type-option=T, 0 sonst.
  518.     (when (stringp (first docstring-and-slotargs))
  519.       (setq docstring (first docstring-and-slotargs))
  520.       (setq slotargs (rest docstring-and-slotargs))
  521.     ) ; sonst stimmen docstring und slotargs bereits.
  522.     ; docstring ist entweder NIL oder ein String.
  523.     ; slotargs sind die restlichen Argumente.
  524.     (if include-option
  525.       (let* ((option (rest include-option))
  526.              (subname (first option))
  527.              (incl-desc (get subname 'DEFSTRUCT-DESCRIPTION)))
  528.         (when (null incl-desc)
  529.           (error #+DEUTSCH "~S ~S: Teilstruktur ~S ist nicht definiert."
  530.                  #+ENGLISH "~S ~S: included structure ~S has not been defined."
  531.                  #+FRANCAIS "~S ~S : La structure incluse ~S n'est pas définie."
  532.                  'defstruct name subname
  533.         ) )
  534.         (setq names (cons name (svref incl-desc 0)))
  535.         (unless (equalp (svref incl-desc 1) type-option)
  536.           (error #+DEUTSCH "~S ~S: Teilstruktur ~S muß vom selben Typ ~S sein."
  537.                  #+ENGLISH "~S ~S: included structure ~S must be of the same type ~S."
  538.                  #+FRANCAIS "~S ~S : La structure incluse ~S doit être du même type ~S."
  539.                  'defstruct name subname type-option
  540.         ) )
  541.         (setq slotlist (nreverse (mapcar #'copy-list (svref incl-desc 3))))
  542.         ; slotlist ist die umgedrehte Liste der vererbten Slots
  543.         (when slotlist (setq include-skip (1+ (second (first slotlist)))))
  544.         ; include-skip >=0 ist die Anzahl der bereits von der Teilstruktur
  545.         ;   verbrauchten Slots, das "size" der Teilstruktur.
  546.         ; Weitere Argumente der :INCLUDE-Option abarbeiten:
  547.         (dolist (slotarg (rest option))
  548.           (let* ((slotname (if (atom slotarg) slotarg (first slotarg)))
  549.                  (slot (find slotname slotlist :key #'first :test #'eq)))
  550.             (when (null slot)
  551.               (error #+DEUTSCH "~S ~S: Teilstruktur ~S hat keine Komponente namens ~S."
  552.                      #+ENGLISH "~S ~S: included structure ~S has no component with name ~S."
  553.                      #+FRANCAIS "~S ~S : La structure incluse ~S n'a pas de composante de nom ~S."
  554.                      'defstruct name subname slotname
  555.             ) )
  556.             (if (atom slotarg)
  557.               (setf (third slot) 'NIL) ; Default auf NIL überschreiben
  558.               (progn
  559.                 (let ((default (second slotarg)))
  560.                   (unless (constantp default)
  561.                     (push
  562.                       `(FUNCTION ,(concat-pnames "DEFAULT-" slotname)
  563.                          (LAMBDA () ,default)
  564.                        )
  565.                       slotdefaultfuns
  566.                     )
  567.                     (setq default (gensym))
  568.                     (push default slotdefaultvars)
  569.                   )
  570.                   (setf (third slot) default)
  571.                 )
  572.                 ; slot-options dieses Slot-Specifier abarbeiten:
  573.                 (do ((slot-arglistr (cddr slotarg) (cddr slot-arglistr)))
  574.                     ((endp slot-arglistr))
  575.                   (let ((slot-keyword (first slot-arglistr))
  576.                         (slot-key-value (second slot-arglistr)))
  577.                     (cond ((eq slot-keyword ':READ-ONLY)
  578.                            (if slot-key-value
  579.                              (setf (fifth slot) t)
  580.                              (if (fifth slot)
  581.                                (error #+DEUTSCH "~S ~S: Der READ-ONLY-Slot ~S von Teilstruktur ~S muß auch in ~S READ-ONLY bleiben."
  582.                                       #+ENGLISH "~S ~S: The READ-ONLY slot ~S of the included structure ~S must remain READ-ONLY in ~S."
  583.                                       #+FRANCAIS "~S ~S : Le composant READ-ONLY ~S de la structure incluse ~S doit rester READ-ONLY dans ~S."
  584.                                       'defstruct name slotname subname name
  585.                                )
  586.                                (setf (fifth slot) nil)
  587.                           )) )
  588.                           ((eq slot-keyword ':TYPE)
  589.                            (unless (subtypep slot-key-value (fourth slot))
  590.                              (error #+DEUTSCH "~S ~S: Der Typ ~S von Slot ~S muß ein Untertyp des in Teilstruktur ~S definierten Typs ~S sein."
  591.                                     #+ENGLISH "~S ~S: The type ~S of slot ~S should be a subtype of the type defined for the included strucure ~S, namely ~S."
  592.                                     #+FRANCAIS "~S ~S : Le type ~S du composant ~S doit être un sous-type du type défini dans la structure incluse ~S, c'est-à-dire ~S."
  593.                                     'defstruct name slot-key-value slotname subname (fourth slot)
  594.                            ) )
  595.                            (setf (fourth slot) slot-key-value)
  596.                           )
  597.                           (t (error #+DEUTSCH "~S ~S: ~S ist keine Slot-Option."
  598.                                     #+ENGLISH "~S ~S: ~S is not a slot option."
  599.                                     #+FRANCAIS "~S ~S : ~S n'est pas un option de composant."
  600.                                     'defstruct name slot-keyword
  601.                           )  )
  602.                 ) ) )
  603.         ) ) ) )
  604.       )
  605.       (setq names name)
  606.     )
  607.     ; names ist die Include-Verschachtelung.
  608.     ; slotlist ist die bisherige Slotliste, umgedreht.
  609.     (when (and named-option ; benannte Structure
  610.                (consp type-option) ; vom Typ (VECTOR ...)
  611.                ; muß den/die Namen enthalten können:
  612.                (not (typep names (second type-option)))
  613.           )
  614.       (error #+DEUTSCH "~S ~S: Structure vom Typ ~S kann den Namen nicht enthalten."
  615.              #+ENGLISH "~S ~S: structure of type ~S can't hold the name."
  616.              #+FRANCAIS "~S ~S : Une structure de type ~S ne peut pas contenir le nom."
  617.              'defstruct name type-option
  618.     ) )
  619.     ; Aufbau der Structure:
  620.     ; names, evtl. include-Slots, initial-offset-option mal NIL, Slots.
  621.     ; Aufbau von Vektor oder Liste:
  622.     ; include-Anteil, initial-offset-option mal NIL, evtl. Name, Slots.
  623.     (setq initial-offset (+ include-skip initial-offset-option))
  624.     (unless (eq type-option 'T)
  625.       (when named-option
  626.         (push
  627.           (list nil ; Kennzeichen für Typerkennungs-Slot
  628.                 (setq initial-offset-option initial-offset)
  629.                 name ; "Defaultwert" = name
  630.                 'SYMBOL ; Typ = Symbol
  631.                 T) ; Read-Only
  632.           slotlist
  633.         )
  634.         (setq initial-offset (1+ initial-offset))
  635.     ) )
  636.     ; Die einzelnen Slots kommen ab initial-offset.
  637.     ; Bei type/=T (also Vektor oder Liste) und named-option sitzt
  638.     ;   der Name in Slot Nummer  initial-offset-option = (1- initial-offset).
  639.     ; Abarbeitung der einzelnen Slots:
  640.     (let ((offset initial-offset))
  641.       (dolist (slotarg slotargs)
  642.         (let (slotname
  643.               default)
  644.           (if (atom slotarg)
  645.             (setq slotname slotarg  default nil)
  646.             (setq slotname (first slotarg)  default (second slotarg))
  647.           )
  648.           (unless (constantp default)
  649.             (push
  650.               `(FUNCTION ,(concat-pnames "DEFAULT-" slotname)
  651.                  (LAMBDA () ,default)
  652.                )
  653.               slotdefaultfuns
  654.             )
  655.             (setq default (gensym))
  656.             (push default slotdefaultvars)
  657.           )
  658.           (when (find slotname slotlist :key #'first :test #'eq)
  659.             (error #+DEUTSCH "~S ~S: Es kann nicht mehrere Slots mit demselben Namen ~S geben."
  660.                    #+ENGLISH "~S ~S: There may be only one slot with the name ~S."
  661.                    #+FRANCAIS "~S ~S : Il ne peut pas y avoir plusieurs composants avec le même nom ~S."
  662.                    'defstruct name slotname
  663.           ) )
  664.           (let ((type t) (read-only nil))
  665.             (when (consp slotarg)
  666.               (do ((slot-arglistr (cddr slotarg) (cddr slot-arglistr)))
  667.                   ((endp slot-arglistr))
  668.                 (let ((slot-keyword (first slot-arglistr))
  669.                       (slot-key-value (second slot-arglistr)))
  670.                   (cond ((eq slot-keyword ':READ-ONLY)
  671.                          (setq read-only (if slot-key-value t nil))
  672.                         )
  673.                         ((eq slot-keyword ':TYPE) (setq type slot-key-value))
  674.                         (t (error #+DEUTSCH "~S ~S: ~S ist keine Slot-Option."
  675.                                   #+ENGLISH "~S ~S: ~S is not a slot option."
  676.                                   #+FRANCAIS "~S ~S : ~S n'est pas une option de composant."
  677.                                   'defstruct name slot-keyword
  678.                         )  )
  679.             ) ) ) )
  680.             (push (list slotname offset default type read-only) slotlist)
  681.         ) )
  682.         (incf offset)
  683.       )
  684.       (setq size offset)
  685.     )
  686.     ; size = Gesamtlänge der Structure
  687.     (setq slotlist (nreverse slotlist))
  688.     (setq slotdefaultfuns (nreverse slotdefaultfuns))
  689.     (setq slotdefaultvars (nreverse slotdefaultvars))
  690.     ; Die slots in slotlist sind jetzt wieder aufsteigend geordnet.
  691.     (setq constructor-forms
  692.       (mapcar
  693.         #'(lambda (constructor-option)
  694.             (if (consp constructor-option)
  695.               (ds-make-boa-constructor
  696.                 constructor-option type-option name names size slotlist
  697.               )
  698.               (progn
  699.                 (if (null keyword-constructor)
  700.                   (setq keyword-constructor constructor-option)
  701.                 )
  702.                 (ds-make-keyword-constructor
  703.                   constructor-option type-option name names size slotlist
  704.           ) ) ) )
  705.         constructor-option-list
  706.     ) )
  707.     ; constructor-forms = Liste der Formen, die die Konstruktoren definieren.
  708.     (let ((index 4))
  709.       (dolist (defaultvar slotdefaultvars)
  710.         (setf (third (find defaultvar slotlist :key #'third :test #'eq))
  711.               `(SVREF (GET ',name 'DEFSTRUCT-DESCRIPTION) ,index)
  712.         )
  713.         (incf index)
  714.     ) )
  715.     ; slotlist enthält nun keine der slotdefaultvars mehr.
  716.     `(EVAL-WHEN (LOAD COMPILE EVAL)
  717.        (LET ,(mapcar #'list slotdefaultvars slotdefaultfuns)
  718.          ,@constructor-forms
  719.          (%PUT ',name 'DEFSTRUCT-DESCRIPTION
  720.                (VECTOR ',names ',type-option ',keyword-constructor ',slotlist
  721.                        ,@slotdefaultvars
  722.        ) )     )
  723.        ,@(if (and named-option predicate-option)
  724.            (ds-make-pred predicate-option type-option name initial-offset-option)
  725.          )
  726.        ,@(if copier-option (ds-make-copier copier-option name type-option))
  727.        ,@(ds-make-accessors name type-option conc-name-option slotlist)
  728.        ,@(ds-make-defsetfs name type-option conc-name-option slotlist)
  729.        (SETF (DOCUMENTATION ',name 'STRUCTURE) ,docstring)
  730.        ,(if print-function-option
  731.           `(%PUT ',name 'STRUCTURE-PRINT ,print-function-option)
  732.           `(REMPROP ',name 'STRUCTURE-PRINT)
  733.         )
  734.        ',name
  735. ) )  )
  736.  
  737.